home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC2.6 / M2RM.MOD < prev    next >
Encoding:
Modula Implementation  |  1992-05-29  |  22.8 KB  |  582 lines  |  [TEXT/MEDT]
  1. IMPLEMENTATION MODULE M2RM; (* JG 2.11.85 / NW 17.12.85 *)
  2.  
  3.   FROM SYSTEM IMPORT ADDRESS, WORD, VAL;
  4.   FROM FileSystem IMPORT File, Response, Lookup, Close,
  5.     ReadChar, WriteChar, ReadWord, WriteWord;
  6.   FROM FileUtil IMPORT Path, ExtLookup, GetCurrentPath, AddPath, GetPos;
  7.   FROM M2SM IMPORT source, IdBuf, id, Diff, Mark;
  8.   FROM M2DM IMPORT ObjClass, Object, ObjPtr, StrForm, Structure, StrPtr,
  9.     Parameter, ParPtr, PDesc, Key, KeyPtr, undftyp, booltyp, chartyp, inttyp,
  10.     cardtyp, dbltyp, lcardtyp, realtyp, lrltyp, stringtyp, bytetyp, wordtyp,
  11.     addrtyp, bitstyp, proctyp, notyp, mainmod, ALLOCATE, ResetHeap, Standard;
  12.   FROM M2LM IMPORT pc, AllocBounds, AllocString;
  13.  
  14.   CONST REFFILE = 334B;
  15.     CTL = -5000B; anchor = 0; ModTag = 1; ProcTag = 2; RefTag = 3; linkage = 4;
  16.     STR = -6000B; enum = 0; range = 1; pointer = 2; set = 3; procTyp = 4;
  17.           funcTyp = 5; array = 6; dynarr = 7; record = 8; opaque = 9;
  18.     CMP = -7000B; parref = 0; par = 1; field = 2;
  19.     OBJ = -10000B; varref = 0; var = 1; const = 2; string = 3; type = 4;
  20.           proc = 5; func = 6; module = 7; svc = 8; svcfunc = 9;
  21.     maxM = 64; minS = 32 (*first non-standard structure*); maxS = 1024;
  22.  
  23.   VAR CurStr: INTEGER;
  24.       f: File; err: BOOLEAN;
  25.       Temps, Fields: ObjPtr;
  26.       Params, lastPar: ParPtr;
  27.       oldPos: LONGINT;
  28.       mark: ADDRESS;
  29.       markId: INTEGER;
  30.  
  31.  
  32.   PROCEDURE ReadId;
  33.     VAR i, L: INTEGER; ch: CHAR;
  34.   BEGIN i := id;
  35.     ReadChar(f, ch); IdBuf[i] := ch; INC(i); L := ORD(ch)-1;
  36.     WHILE L > 0 DO
  37.       ReadChar(f, ch); IdBuf[i] := ch; INC(i); DEC(L)
  38.     END;
  39.     id := i
  40.   END ReadId;
  41.  
  42.   PROCEDURE InitRef;
  43.   BEGIN
  44.     WITH mainmod^ DO left := NIL; right := NIL; next := NIL END;
  45.     ALLOCATE(ModList, SIZE(Object)); ALLOCATE(Temps, SIZE(Object));
  46.     ALLOCATE(Fields, SIZE(Object)); ALLOCATE(Params, SIZE(Parameter));
  47.     WITH ModList^ DO class := Header;
  48.       next := mainmod; last := mainmod; left := NIL; right := NIL
  49.     END;
  50.     ModNo := 1;
  51.     WITH Temps^ DO class := Header;
  52.       next := NIL; last := Temps; left := NIL; right := NIL
  53.     END;
  54.     WITH Fields^ DO class := Header;
  55.       next := NIL; last := Fields; left := NIL; right := NIL
  56.     END;
  57.     Params^.next := NIL; lastPar := Params
  58.   END InitRef;
  59.  
  60.   PROCEDURE Insert(root, obj: ObjPtr): ObjPtr;
  61.     VAR ob0, ob1: ObjPtr; d: INTEGER;
  62.   BEGIN ob0 := root; ob1 := ob0^.right; d := 1;
  63.     LOOP
  64.       IF ob1 # NIL THEN
  65.         d := Diff(obj^.name, ob1^.name);
  66.         IF d < 0 THEN ob0 := ob1; ob1 := ob1^.left
  67.         ELSIF d > 0 THEN ob0 := ob1; ob1 := ob1^.right
  68.         ELSE EXIT
  69.         END
  70.       ELSE ob1 := obj;
  71.         IF d < 0 THEN ob0^.left := ob1 ELSE ob0^.right := ob1 END;
  72.         ob1^.left := NIL; ob1^.right := NIL; EXIT
  73.       END
  74.     END;
  75.     RETURN ob1
  76.   END Insert;
  77.  
  78.   PROCEDURE MarkHeap;
  79.   BEGIN
  80.     markId := id; ALLOCATE(mark, 0);
  81.   END MarkHeap;
  82.  
  83.   PROCEDURE Reset;
  84.   BEGIN
  85.     id := markId; ResetHeap(mark);
  86.   END Reset;
  87.  
  88.   PROCEDURE InRef(VAR filename: ARRAY OF CHAR; VAR hdr: ObjPtr;
  89.                   VAR adr, pno: INTEGER);
  90.     VAR GlbMod: ARRAY [0..maxM] OF ObjPtr;
  91.         Struct: ARRAY [0..maxS] OF StrPtr;
  92.         CurMod, FileType, block, m, p, s: INTEGER;
  93.         newobj, obj: ObjPtr;
  94.         newpar: ParPtr; newstr: StrPtr;
  95.         ch: CHAR; ok: BOOLEAN; path: Path;
  96.   BEGIN
  97.     ExtLookup(f, filename, FALSE, ok);
  98.     IF ok THEN
  99.       GetCurrentPath(path);
  100.       AddPath(path, filename, filename);
  101.     END;
  102.     IF ok THEN ReadWord(f, FileType);
  103.       IF FileType = REFFILE THEN
  104.         Struct[1] := undftyp; Struct[2] := booltyp; Struct[3] := chartyp;
  105.         Struct[4] := inttyp; Struct[5] := cardtyp; Struct[6] := dbltyp;
  106.         Struct[7] := realtyp; Struct[8] := lrltyp; Struct[9] := bitstyp;
  107.         Struct[10] := proctyp; Struct[11] := stringtyp;
  108.         Struct[12] := addrtyp; Struct[13] := bytetyp; Struct[14] := wordtyp;
  109.         Struct[15] := lcardtyp;
  110.         CurMod := 0; CurStr := minS; err := FALSE;
  111.         MarkHeap;
  112.         LOOP ReadWord(f, block);
  113.           IF block < CMP THEN block := block - OBJ;
  114.             IF block > svcfunc THEN err := TRUE; Mark(86); EXIT END;
  115.             ALLOCATE(newobj, SIZE(Object)); m := 0;
  116.             WITH newobj^ DO next := NIL;
  117.               CASE block OF
  118.                 var    : class := Var; ReadWord(f, s); typ := Struct[s];
  119.                          varpar := FALSE; vmod := GlbMod[0]^.right^.modno;
  120.                          ReadWord(f, vlev); ReadWord(f, vadr)
  121.               | const  : class := Const; ReadWord(f, s); typ := Struct[s];
  122.                          ReadWord(f, m);
  123.                          ReadChar(f, ch);
  124.                          CASE ORD(ch) OF
  125.                            2: ReadChar(f, ch); conval.Ch := ch;
  126.                          | 3: ReadWord(f, conval.I);
  127.                          | 5: ReadWord(f, conval.D0); ReadWord(f, conval.D1);
  128.                          | 9: ReadWord(f, conval.D0); ReadWord(f, conval.D1);
  129.                               ReadWord(f, conval.D2); ReadWord(f, conval.D3);
  130.                          ELSE
  131.                            Mark(86);
  132.                          END;
  133.               | string : class := Const; ReadWord(f, s); typ := Struct[s];
  134.                          conval.D2 := id; ReadId;
  135.                          AllocString(conval.D2, conval.D0, conval.D1);
  136.                          (*conval.D1 := id - conval.D2; conval.D0 := -1*)
  137.               | type   : class := Typ; ReadWord(f, s); typ := Struct[s];
  138.                          IF typ^.strobj = NIL THEN typ^.strobj := newobj END;
  139.                          ReadWord(f, m); mod := GlbMod[m]^.right
  140.               | proc, func : class := Proc;
  141.                          IF block = func THEN ReadWord(f, s); typ := Struct[s]
  142.                            ELSE typ := notyp
  143.                          END;
  144.                          ALLOCATE(pd, SIZE(PDesc));
  145.                          ReadWord(f, pd^.num); ReadWord(f, pd^.lev);
  146.                          ReadWord(f, pd^.adr); ReadWord(f, pd^.size);
  147.                          pd^.forward := FALSE; pd^.exp := FALSE;
  148.                       (* pd^.extern := TRUE; pd^.link := 0; *)
  149.                          firstLocal := NIL; firstParam := Params^.next;
  150.                          Params^.next := NIL; lastPar := Params;
  151.                          pmod := GlbMod[0]^.right^.modno
  152.               | svc, svcfunc: class := Code;
  153.                          IF block = svcfunc THEN ReadWord(f, s); typ := Struct[s]
  154.                            ELSE typ := notyp
  155.                          END;
  156.                          ReadWord(f, cnum); std := NonStand;
  157.                          firstArg := Params^.next;
  158.                          Params^.next := NIL; lastPar := Params
  159.               END;
  160.               name := id; ReadId; exported := TRUE;
  161.               obj := Insert(GlbMod[m]^.right, newobj);
  162.               IF obj = newobj THEN (*new object*)
  163.                 GlbMod[m]^.last^.next := newobj; GlbMod[m]^.last := newobj;
  164.                 IF (class = Const) & (typ^.form = Enum) THEN
  165.                   conval.prev := typ^.ConstLink; typ^.ConstLink := newobj
  166.                 END;
  167.                 MarkHeap
  168.               ELSE
  169.                 IF obj^.class = Typ THEN Struct[s] := obj^.typ END;
  170.                 Reset
  171.               END
  172.             END
  173.           ELSIF block < STR THEN block := block - CMP;
  174.             IF block > field THEN err := TRUE; Mark(86); EXIT END;
  175.             IF block = field THEN
  176.               ALLOCATE(newobj, SIZE(Object));
  177.               WITH newobj^ DO
  178.                 class := Field; next := NIL;
  179.                 ReadWord(f, s); typ := Struct[s];
  180.                 ReadWord(f, offset); name := id; ReadId;
  181.                 newobj := Insert(Fields, newobj)
  182.               END;
  183.               Fields^.last^.next := newobj; Fields^.last := newobj
  184.             ELSE (*parameter*)
  185.               ALLOCATE(newpar, SIZE(Parameter));
  186.               WITH newpar^ DO
  187.                 next := NIL; ReadWord(f, s); typ := Struct[s];
  188.                 varpar := block = parref;
  189.                 lastPar^.next := newpar; lastPar := newpar
  190.               END
  191.             END
  192.           ELSIF block < CTL THEN block := block - STR;
  193.             IF block > opaque THEN err := TRUE; Mark(86); EXIT END;
  194.             ALLOCATE(newstr, SIZE(Structure));
  195.             WITH newstr^ DO
  196.               strobj := NIL; ReadWord(f, size); ref := 0;
  197.               CASE block OF
  198.                 enum    : form := Enum; ReadWord(f, NofConst);
  199.                           ConstLink := NIL
  200.               | range   : form := Range;
  201.                           ReadWord(f, s); RBaseTyp := Struct[s];
  202.                           ReadWord(f, min); ReadWord(f, max);
  203.                           AllocBounds(min, max, size, BndAdr)
  204.               | pointer : form := Pointer; PBaseTyp := NIL;
  205.                           BaseId := 0;
  206.                           MarkHeap
  207.               | set     : form := Set; ReadWord(f, s);
  208.                           SBaseTyp := Struct[s]
  209.               | procTyp, funcTyp : form := ProcTyp;
  210.                           IF block = funcTyp THEN
  211.                             ReadWord(f, s); resTyp := Struct[s]
  212.                           ELSE resTyp := notyp
  213.                           END;
  214.                           firstPar := Params^.next;
  215.                           Params^.next := NIL; lastPar := Params
  216.               | array   : form := Array; ReadWord(f, s);
  217.                           ElemTyp := Struct[s]; dyn := FALSE;
  218.                           ReadWord(f, s); IndexTyp := Struct[s]
  219.               | dynarr  : form := Array; ReadWord(f, s);
  220.                           ElemTyp := Struct[s]; dyn := TRUE;
  221.                           IndexTyp := NIL
  222.               | record  : form := Record;
  223.                           firstFld := Fields^.right; Fields^.right := NIL;
  224.                           Fields^.next := NIL; Fields^.last := Fields
  225.               | opaque  : form := Opaque
  226.               END
  227.             END;
  228.             IF CurStr > maxS THEN err := TRUE; Mark(98); EXIT END;
  229.             Struct[CurStr] := newstr;
  230.             CurStr := CurStr + 1
  231.           ELSIF block < 0 THEN block := block - CTL;
  232.             IF block = linkage THEN ReadWord(f, s); ReadWord(f, p);
  233.               IF Struct[p]^.PBaseTyp # NIL THEN
  234.                 Reset
  235.               ELSE Struct[p]^.PBaseTyp := Struct[s];
  236.                 MarkHeap
  237.               END
  238.             ELSIF block = ModTag THEN (*main module*) ReadWord(f, m)
  239.             ELSIF block = anchor THEN
  240.               ALLOCATE(newobj, SIZE(Object));
  241.               WITH newobj^ DO
  242.                 class := Module; typ := NIL; left := NIL; right := NIL;
  243.                 ALLOCATE(key, SIZE(Key));
  244.                 ReadWord(f, key^.k0); ReadWord(f, key^.k1); ReadWord(f, key^.k2);
  245.                 firstObj := NIL; root := NIL; name := id; ReadId
  246.               END;
  247.               IF CurMod > maxM THEN Mark(96); EXIT END;
  248.               ALLOCATE(GlbMod[CurMod], SIZE(Object));
  249.               MarkHeap;
  250.               WITH GlbMod[CurMod]^ DO
  251.                 class := Header; kind := Module; typ := NIL;
  252.                 next := NIL; left := NIL; last := GlbMod[CurMod];
  253.                 obj := ModList^.next; (*find mod*)
  254.                 WHILE (obj # NIL) & (Diff(obj^.name, newobj^.name) # 0) DO
  255.                   obj := obj^.next
  256.                 END;
  257.                 IF obj # NIL THEN GlbMod[CurMod]^.right := obj;
  258.                   IF (CurMod = 0) & (obj = mainmod) THEN
  259.                     (*newobj is own definition module*)
  260.                     obj^.key^ := newobj^.key^
  261.                   ELSIF (obj^.key^.k0 # newobj^.key^.k0)
  262.                      OR (obj^.key^.k1 # newobj^.key^.k1)
  263.                      OR (obj^.key^.k2 # newobj^.key^.k2) THEN Mark(85)
  264.                   ELSIF (CurMod = 0) & (obj^.firstObj # NIL) THEN
  265.                     CurMod := 1; EXIT (*module already loaded*)
  266.                   END;
  267.                   Reset
  268.                 ELSE GlbMod[CurMod]^.right := newobj;
  269.                   newobj^.next := NIL; newobj^.modno := ModNo; INC(ModNo);
  270.                   ModList^.last^.next := newobj; ModList^.last := newobj;
  271.                   MarkHeap
  272.                 END
  273.               END;
  274.               CurMod := CurMod + 1
  275.             ELSIF block = RefTag THEN
  276.               ReadWord(f, adr); ReadWord(f, pno); EXIT
  277.             ELSE err := TRUE; Mark(86); EXIT
  278.             END
  279.           ELSE (*line block*) err := TRUE; Mark(86); EXIT
  280.           END
  281.         END;
  282.         IF NOT err & (CurMod # 0) THEN hdr := GlbMod[0];
  283.           hdr^.right^.root := hdr^.right^.right;
  284.           (*leave hdr^.right.right for later searches*)
  285.           hdr^.right^.firstObj := hdr^.next
  286.         ELSE hdr := NIL
  287.         END
  288.       ELSE Mark(86); hdr := NIL
  289.       END;
  290.       Close(f)
  291.     ELSE Mark(88); hdr := NIL
  292.     END
  293.   END InRef;
  294.  
  295.   PROCEDURE WriteId(i: INTEGER);
  296.     VAR L: INTEGER;
  297.   BEGIN L := ORD(IdBuf[i]);
  298.     REPEAT WriteChar(RefFile, IdBuf[i]); INC(i); DEC(L)
  299.     UNTIL L = 0
  300.   END WriteId;
  301.  
  302.   PROCEDURE OpenRef;
  303.     VAR obj: ObjPtr;
  304.   BEGIN WriteWord(RefFile, REFFILE);
  305.     obj := ModList^.next;
  306.     WHILE obj # NIL DO
  307.       WriteWord(RefFile, CTL+anchor);
  308.       WITH obj^ DO WriteWord(RefFile, key^.k0);
  309.         WriteWord(RefFile, key^.k1); WriteWord(RefFile, key^.k2);
  310.         WriteId(name)
  311.       END;
  312.       obj := obj^.next
  313.     END;
  314.     CurStr := minS;
  315.     oldPos := 0D
  316.   END OpenRef;
  317.  
  318.   PROCEDURE OutPar(prm: ParPtr);
  319.   BEGIN
  320.     WHILE prm # NIL DO (*out param*)
  321.       WITH prm^ DO
  322.         IF varpar THEN WriteWord(RefFile, CMP+parref)
  323.           ELSE WriteWord(RefFile, CMP+par)
  324.         END;
  325.         WriteWord(RefFile, typ^.ref)
  326.       END;
  327.       prm := prm^.next
  328.     END
  329.   END OutPar;
  330.  
  331.   PROCEDURE OutStr(str: StrPtr);
  332.     VAR obj: ObjPtr; par: ParPtr;
  333.  
  334.     PROCEDURE OutFldStrs(fld: ObjPtr);
  335.     BEGIN
  336.       WHILE fld # NIL DO
  337.         IF fld^.typ^.ref = 0 THEN OutStr(fld^.typ) END;
  338.         fld := fld^.next
  339.       END
  340.     END OutFldStrs;
  341.  
  342.     PROCEDURE OutFlds(fld: ObjPtr);
  343.     BEGIN
  344.       WHILE fld # NIL DO
  345.         WITH fld^ DO
  346.           WriteWord(RefFile, CMP+field); WriteWord(RefFile, typ^.ref);
  347.           WriteWord(RefFile, offset); WriteId(name)
  348.         END;
  349.         fld := fld^.next
  350.       END
  351.     END OutFlds;
  352.  
  353.   BEGIN
  354.     WITH str^ DO
  355.       CASE form OF
  356.         Enum    : WriteWord(RefFile, STR+enum); WriteWord(RefFile, size);
  357.                   WriteWord(RefFile, NofConst)
  358.       | Range   : IF RBaseTyp^.ref = 0 THEN OutStr(RBaseTyp) END;
  359.                   WriteWord(RefFile, STR+range); WriteWord(RefFile, size);
  360.                   WriteWord(RefFile, RBaseTyp^.ref);
  361.                   WriteWord(RefFile, min); WriteWord(RefFile, max)
  362.       | Pointer : ALLOCATE(obj, SIZE(Object));
  363.                   WITH obj^ DO left := NIL; next := NIL;
  364.                     class := Temp; typ := PBaseTyp; baseref := CurStr;
  365.                     Temps^.last^.next := obj; Temps^.last := obj
  366.                   END;
  367.                   WriteWord(RefFile, STR+pointer); WriteWord(RefFile, size)
  368.       | Set     : IF SBaseTyp^.ref = 0 THEN OutStr(SBaseTyp) END;
  369.                   WriteWord(RefFile, STR+set); WriteWord(RefFile, size);
  370.                   WriteWord(RefFile, SBaseTyp^.ref)
  371.       | ProcTyp : par := firstPar;
  372.                   WHILE par # NIL DO (*out param structure*)
  373.                     IF par^.typ^.ref = 0 THEN OutStr(par^.typ) END;
  374.                     par := par^.next
  375.                   END;
  376.                   OutPar(firstPar);
  377.                   IF resTyp # notyp THEN
  378.                     IF resTyp^.ref = 0 THEN OutStr(resTyp) END;
  379.                     WriteWord(RefFile, STR+funcTyp); WriteWord(RefFile, size);
  380.                     WriteWord(RefFile, resTyp^.ref)
  381.                   ELSE WriteWord(RefFile, STR+procTyp); WriteWord(RefFile, size)
  382.                   END
  383.       | Array   : IF ElemTyp^.ref = 0 THEN OutStr(ElemTyp) END;
  384.                   IF dyn THEN WriteWord(RefFile, STR+dynarr);
  385.                     WriteWord(RefFile, size); WriteWord(RefFile, ElemTyp^.ref)
  386.                   ELSE
  387.                     IF IndexTyp^.ref = 0 THEN OutStr(IndexTyp) END;
  388.                     WriteWord(RefFile, STR+array); WriteWord(RefFile, size);
  389.                     WriteWord(RefFile, ElemTyp^.ref);
  390.                     WriteWord(RefFile, IndexTyp^.ref)
  391.                   END
  392.       | Record  : OutFldStrs(firstFld); OutFlds(firstFld);
  393.                   WriteWord(RefFile, STR+record); WriteWord(RefFile, size)
  394.       | Opaque  : WriteWord(RefFile, STR+opaque); WriteWord(RefFile, size)
  395.       END;
  396.       ref := CurStr; CurStr := CurStr + 1
  397.     END
  398.   END OutStr;
  399.  
  400.   PROCEDURE OutExt(str: StrPtr);
  401.     VAR obj: ObjPtr; par: ParPtr;
  402.  
  403.     PROCEDURE OutFlds(fld: ObjPtr);
  404.     BEGIN
  405.       WHILE fld # NIL DO
  406.         IF fld^.typ^.ref = 0 THEN OutExt(fld^.typ) END;
  407.         fld := fld^.next
  408.       END
  409.     END OutFlds;
  410.  
  411.   BEGIN
  412.     WITH str^ DO
  413.       CASE form OF
  414.         Range   : IF RBaseTyp^.ref = 0 THEN OutExt(RBaseTyp) END
  415.       | Set     : IF SBaseTyp^.ref = 0 THEN OutExt(SBaseTyp) END
  416.       | ProcTyp : par := firstPar;
  417.                   WHILE par # NIL DO
  418.                     IF par^.typ^.ref = 0 THEN OutExt(par^.typ) END;
  419.                     par := par^.next
  420.                   END;
  421.                   IF (resTyp # notyp) & (resTyp^.ref = 0) THEN OutExt(resTyp) END
  422.       | Array   : IF ElemTyp^.ref = 0 THEN OutExt(ElemTyp) END;
  423.                   IF NOT dyn THEN OutExt(IndexTyp) END
  424.       | Record  : OutFlds(firstFld)
  425.       | Enum, Pointer, Opaque :
  426.       END;
  427.       IF (strobj # NIL) & (strobj^.mod^.modno # 0) THEN
  428.         IF ref = 0 THEN OutStr(str) END;
  429.         IF form = Enum THEN obj := ConstLink;
  430.           WHILE obj # NIL DO
  431.             WriteWord(RefFile, OBJ+const);
  432.             WriteWord(RefFile, ref);
  433.             WriteWord(RefFile, strobj^.mod^.modno);
  434.             WriteChar(RefFile, 2C); WriteChar(RefFile, obj^.conval.Ch);
  435.             WriteId(obj^.name);
  436.             obj := obj^.conval.prev
  437.           END
  438.         END;
  439.         WriteWord(RefFile, OBJ+type);
  440.         WriteWord(RefFile, ref);
  441.         WriteWord(RefFile, strobj^.mod^.modno);
  442.         WriteId(strobj^.name)
  443.       END
  444.     END
  445.   END OutExt;
  446.  
  447.   PROCEDURE OutObj(obj: ObjPtr);
  448.     VAR par: ParPtr;
  449.   BEGIN
  450.     WITH obj^ DO
  451.       CASE class OF
  452.         Module : WriteWord(RefFile, OBJ+module); WriteWord(RefFile, modno)
  453.       | Proc   : par := firstParam;
  454.                  WHILE par # NIL DO
  455.                    IF par^.typ^.ref = 0 THEN OutExt(par^.typ) END;
  456.                    par := par^.next
  457.                  END;
  458.                  IF (typ # notyp) & (typ^.ref = 0) THEN OutExt(typ) END;
  459.                  par := firstParam;
  460.                  WHILE par # NIL DO (*out param structure*)
  461.                    IF par^.typ^.ref = 0 THEN OutStr(par^.typ) END;
  462.                    par := par^.next
  463.                  END;
  464.                  IF (typ # notyp) & (typ^.ref = 0) THEN OutStr(typ) END;
  465.                  OutPar(firstParam);
  466.                  IF typ # notyp THEN
  467.                    WriteWord(RefFile, OBJ+func); WriteWord(RefFile, typ^.ref)
  468.                  ELSE WriteWord(RefFile, OBJ+proc)
  469.                  END;
  470.                  WriteWord(RefFile, pd^.num); WriteWord(RefFile, pd^.lev);
  471.                  WriteWord(RefFile, pd^.adr); WriteWord(RefFile, pd^.size)
  472.       | Code   : par := firstArg;
  473.                  WHILE par # NIL DO
  474.                    IF par^.typ^.ref = 0 THEN OutExt(par^.typ) END;
  475.                    par := par^.next
  476.                  END;
  477.                  IF (typ # notyp) & (typ^.ref = 0) THEN OutExt(typ) END;
  478.                  par := firstArg;
  479.                  WHILE par # NIL DO (*out param structure*)
  480.                    IF par^.typ^.ref = 0 THEN OutStr(par^.typ) END;
  481.                    par := par^.next
  482.                  END;
  483.                  IF (typ # notyp) & (typ^.ref = 0) THEN OutStr(typ) END;
  484.                  OutPar(firstArg);
  485.                  IF typ # notyp THEN
  486.                    WriteWord(RefFile, OBJ+svcfunc); WriteWord(RefFile, typ^.ref)
  487.                  ELSE WriteWord(RefFile, OBJ+svc)
  488.                  END;
  489.                  WriteWord(RefFile,VAL(INTEGER,cnum))
  490.       | Const  : IF typ^.ref = 0 THEN OutExt(typ) END;
  491.                  IF typ^.ref = 0 THEN OutStr(typ) END;
  492.                  IF typ^.form = String THEN WriteWord(RefFile, OBJ+string);
  493.                    WriteWord(RefFile, typ^.ref); WriteId(conval.D2)
  494.                  ELSE WriteWord(RefFile, OBJ+const);
  495.                    WriteWord(RefFile, typ^.ref);
  496.                    WriteWord(RefFile, 0); (*main*)
  497.                    WriteChar(RefFile, VAL(CHAR,typ^.size+1));
  498.                    CASE typ^.size OF
  499.                      1: WriteChar(RefFile, conval.Ch);
  500.                    | 2: WriteWord(RefFile, conval.I);
  501.                    | 4: WriteWord(RefFile, conval.D0);
  502.                         WriteWord(RefFile, conval.D1);
  503.                    | 8: WriteWord(RefFile, conval.D0);
  504.                         WriteWord(RefFile, conval.D1);
  505.                         WriteWord(RefFile, conval.D2);
  506.                         WriteWord(RefFile, conval.D3);
  507.                    ELSE
  508.                    END;
  509.                  END
  510.       | Typ    : IF typ^.ref = 0 THEN OutExt(typ) END;
  511.                  IF typ^.ref = 0 THEN OutStr(typ) END;
  512.                  WriteWord(RefFile, OBJ+type);
  513.                  WriteWord(RefFile, typ^.ref); WriteWord(RefFile, 0) (*main*)
  514.       | Var    : IF typ^.ref = 0 THEN OutExt(typ) END;
  515.                  IF typ^.ref = 0 THEN OutStr(typ) END;
  516.                  IF varpar THEN WriteWord(RefFile, OBJ+varref)
  517.                    ELSE WriteWord(RefFile, OBJ+var)
  518.                  END;
  519.                  WriteWord(RefFile, typ^.ref);
  520.                  WriteWord(RefFile, vlev); WriteWord(RefFile, vadr)
  521.       | Temp   :
  522.       END;
  523.       WriteId(name)
  524.     END
  525.   END OutObj;
  526.  
  527.   PROCEDURE OutLink;
  528.     VAR obj: ObjPtr;
  529.   BEGIN obj := Temps^.next;
  530.     WHILE obj # NIL DO
  531.       WITH obj^ DO
  532.         IF typ^.ref = 0 THEN OutExt(typ) END;
  533.         IF typ^.ref = 0 THEN OutStr(typ) END;
  534.         WriteWord(RefFile, CTL+linkage);
  535.         WriteWord(RefFile, typ^.ref);
  536.         WriteWord(RefFile, baseref)
  537.       END;
  538.       obj := obj^.next
  539.     END;
  540.     Temps^.next := NIL; Temps^.last := Temps
  541.   END OutLink;
  542.  
  543.   PROCEDURE OutUnit(unit: ObjPtr);
  544.     VAR lev0, obj: ObjPtr;
  545.   BEGIN ALLOCATE(lev0, 0);
  546.     IF unit^.class = Proc THEN obj := unit^.firstLocal;
  547.       WHILE obj # NIL DO OutObj(obj); obj := obj^.next END;
  548.       OutLink;
  549.       WriteWord(RefFile, CTL+ProcTag);
  550.       WriteWord(RefFile, unit^.pd^.num);
  551.     ELSIF unit^.class = Module THEN obj := unit^.firstObj;
  552.       WHILE obj # NIL DO OutObj(obj); obj := obj^.next END;
  553.       OutLink;
  554.       WriteWord(RefFile, CTL+ModTag);
  555.       WriteWord(RefFile, unit^.modno)
  556.     END;
  557.     ResetHeap(lev0)
  558.   END OutUnit;
  559.  
  560.   PROCEDURE RefPoint;
  561.     VAR pos: LONGINT;
  562.   BEGIN
  563.     GetPos(source, pos);
  564.     WriteWord(RefFile, pc);
  565.     WriteWord(RefFile, VAL(WORD, pos - oldPos));
  566.     oldPos := pos
  567.   END RefPoint;
  568.  
  569.   PROCEDURE CloseRef(adr, pno: INTEGER);
  570.   BEGIN
  571.     WriteWord(RefFile, CTL+RefTag);
  572.     WriteWord(RefFile, adr); WriteWord(RefFile, pno);
  573.   END CloseRef;
  574.  
  575. BEGIN
  576.   undftyp^.ref := 1; booltyp^.ref := 2; chartyp^.ref := 3; inttyp^.ref := 4;
  577.   cardtyp^.ref := 5; dbltyp^.ref := 6; realtyp^.ref := 7; lrltyp^.ref := 8;
  578.   bitstyp^.ref := 9; proctyp^.ref := 10; stringtyp^.ref := 11;
  579.   addrtyp^.ref := 12; bytetyp^.ref := 13; wordtyp^.ref := 14;
  580.   lcardtyp^.ref := 15;
  581. END M2RM. (* Copyright Departement Informatik, ETH Zuerich, Switzerland, 1992 *)
  582.